00100	ENTRY DUMMY;
00200	BEGIN	"KLEIN"
00300		REQUIRE "ABBREV" SOURCE_FILE;
00400	α ...after Felix Klein, 1849-1925, German Mathematician;
00500		EXTERNAL STRING ARRAY  NAME[1:50];
00600		REQUIRE "GEOMES" SOURCE_FILE;
00700	
00800		DEFINE THRICE="FOR I←1 STEP 1 UNTIL 3 DO";
00900	
01000	
01100	INTERNAL ISUBR PYRAMID (ITG F);
01200	BEGIN	"PYRAMID"
01300		INTEGER V,V0,E,E0,E1,E2,V1,V2,PEAK,EX;
01400		REAL X,Y,Z; INTEGER I;
01500	
01600	α VERTEX ARGUMENT - GIVEN THE PEAK FORM THE BASE;
01700	IF VTYPE(F) THEN
01800	BEGIN
01900		V ← F; E0←E2←PED(V); V2←OTHER(E2,V);
02000		DO ⊂ E1←E2;V1←V2; E2←ECCW(E1,V);V2←OTHER(E2,V);
02100		     F←FCCW(E1,V); IF ¬LINKED(V1,V2) THEN EX←MKFE(V1,F,V2);
02200		⊃ UNTIL E2=E0; RETURN(V);
02300	END;
02400	
02500	α FACE ARGUMENT - GIVEN THE BASE FORM THE PEAK;
02600		X←Y←Z←I←0;
02700		E←E0←PED(F);
02800		V0 ← VCW(E0,F);
02900		PEAK ← MKEV(F,V0);
03000		WHILE TRUE DO 
03100	BEGIN
03200		V ← VCCW(E,F);
03300		X←X+XWC(V); Y←Y+YWC(V); Z←Z+ZWC(V);
03400		INCREM(I);
03500		IF V=V0 THEN DONE;
03600		E ← ECCW(E,F);
03700		EX ← MKFE(PEAK,F,V);
03800	END;
03900		DACR(X/I,PEAK-3);
04000		DACR(Y/I,PEAK-2);
04100		DACR(Z/I,PEAK-1);
04200		RETURN(PEAK);
04300	END	"PYRAMID";
     

00100	INTERNAL BOOLEAN SUBR CONVEX (ITG F);
00200	BEGIN "CONVEX"
00300		ITG V1,V,V2,E,E0,I,FLG;
00400		REAL A,B,C,X1,Y1,X2,Y2,X,Y,P,Q;
00500		XSUBR FACOEF(ITG F,FLG);
00600		FACOEF(F,0);FLG←FALSE;
00700	α SELECT LARGEST FACE COEFFICIENT;
00800		I ← (IF ABS(AA(F))>ABS(BB(F)) THEN
00900		    (IF ABS(AA(F))>ABS(CC(F)) THEN 0 ELSE 2) ELSE
01000		    (IF ABS(BB(F))>ABS(CC(F)) THEN 1 ELSE 2));
01100	
01200		E0←E←PED(F); V1←0; V←VCW(E,F); V2←VCCW(E,F);
01210		X ← CASE I OF ( YWC(V),ZWC(V),XWC(V) );
01212		Y ← CASE I OF ( ZWC(V),XWC(V),YWC(V) );
01220		X2 ← CASE I OF ( YWC(V2),ZWC(V2),XWC(V2) );
01222		Y2 ← CASE I OF ( ZWC(V2),XWC(V2),YWC(V2) );
01300	
01400	α A POLYGON IS CONVEX IF ALL ITS INTERIOR ANGLES ARE LESS THAN π;
01500	DO BEGIN
01600		V1 ← V; V ← V2; V2 ← VCCW(E,F); E ← ECCW(E,F);
01700		X1 ← X; X ← X2; X2 ← CASE I OF ( YWC(V2),ZWC(V2),XWC(V2) );
01800		Y1 ← Y; Y ← Y2; Y2 ← CASE I OF ( ZWC(V2),XWC(V2),YWC(V2) );
01900		A ← Y1-Y; B ← X-X1; C ← X1*Y - X*Y1;
02000		P←Q;Q←A*X2+B*Y2+C;
02050		IF  FLG∧(P⊗Q)<0 THEN RETURN(FALSE) ELSE FLG←TRUE;
02100	END UNTIL E=E0;
02200		RETURN(TRUE);
02300	END "CONVEX";
     

00100	INTERNAL ISUBR MKCONVEX (ITG Q);
00200	BEGIN "MKCONVEX"
00300		ITG B,F;
00400		IF FTYPE(Q)∧CONVEX(Q) THEN OUTSTR("	CONVEX"&↓)
00500		ELSE OUTSTR("	CONCAVE"&↓);
00600	END;
     

00100	INTERNAL ISUBR KILLF (ITG F);
00200	BEGIN "KILLF"
00300		ITG A,E,V,V0,N; REAL X,Y,Z;
00400		
00500		E←PED(F); V0←VCW(E,F); V←VCCW(E,F); A←ECCW(E,F);
00600		F←KLFE(E);
00700	
00800		X←XWC(V); Y←YWC(V); Z←ZWC(V); N←1;
00900		DO BEGIN
01000			E←A;A←ECCW(A,F);
01100			IF PVT(E)=V THEN INVERT(E);V←KLVE(E);
01200			X ← X+XWC(V); Y ← Y+YWC(V); Z ← Z+ZWC(V); INCREM(N);
01300		END UNTIL V=V0;
01400	
01500	α PLACE VERTEX AT CENTER OF THE DECEASED FACE;
01600		XWC(V0)←X/N;	YWC(V0)←Y/N;	ZWC(V0)←Z/N;
01700		RETURN(V0);
01800	END "KILLF";
     

00100	INTERNAL ISUBR SWEEP (ITG F,META,CTRL);
00200	BEGIN	"SWEEP"
00300		INTEGER I,NN,NCOUNT;
00400		INTEGER V0,V1,V2,Q;
00500		INTEGER U0,U1,U2,E,E0,F0,CELL,EVV,EUV;
00600	
00700		IF VTYPE(F) THEN RETURN(PYRAMID(F));
00800		IF ¬FTYPE(F) THEN RETURN(F);
00900		NN←NCOUNT←NCNT(F);
01000		NN ← 0 MAX NN;
01100		F0←F; E0 ← E ← PED(F);
01200	
01300	α HANDLE POSSIBLE WIRE SWEEP CASE;
01400		IF E=PCW(E) THEN
01500	BEGIN	"WIRE SWEEP"
01600		FOR I←2 TO ABS(NCOUNT) DO E←NCW(E);
01700		V1←NVT(E); V2←MKEV(F,V1);
01800		WHILE TRUE DO
01900		BEGIN "COPY'N'CDR"
02000			V1←PVT(E); V2←MKEV(F,V2);
02100			DAC(LAC(V1-3),V2-3);
02200			DAC(LAC(V1-2),V2-2);
02300			DAC(LAC(V1-1),V2-1);
02400			IF E=PCW(E) THEN DONE ELSE E←PCW(E);
02500		END "COPY'N'CDR";
02600		E ← MKFE(V1,F,V2);
02700		F ← NFACE(E);
02800		FOR I←1 TO (ABS(NCOUNT)-1) DO
02900		BEGIN "CDR'N'JOIN"
03000			Q←ECCW(E,F); V1 ← OTHER(Q,V1);
03100			Q← ECW(E,F); V2 ← OTHER(Q,V2);
03200			E ← MKFE(V2,F,V1);
03300		END "CDR'N'JOIN";
03400		Q←PED(F0); Q←ECCW(Q,F0); PED.(Q,F0);
03500		NCNT.(NCOUNT,F0);
03600		RETURN(F0);
03700	END "WIRE SWEEP";
03800	
03900		IF META∧¬CTRL THEN ⊂ F ← PYRAMID(F);RETURN(F);⊃;
     

00100	α THE NN & NCOUNT ARE FOR LAMINA PARTIAL FACE SWEEPING;
00200		IF NN≠0 THEN E←ECCW(E,F)ELSE NN←ABS(NCOUNT);
00300	
00400	α MAKE PED SPOKE;
00500		U1 ← U0 ← VCW(E,F);
00600		V1 ← V0 ← MKEV(F,U0);
00700	
00800	α MAKE CELLS;
00900	DO BEGIN "CELLS"
01000		U2 ← VCCW(E,F);
01100		E  ← ECCW(E,F);
01200		V2 ← (IF U2=U0 THEN V0 ELSE MKEV(F,U2));
01300		EVV ← MKFE(V1,F,V2);
01400		IF NCOUNT ∧ ABS(NCOUNT)=NN THEN E0←EVV;
01500		CELL ← NFACE(EVV);
01600		NCNT.(4,CELL);
01700	α ANTI-PRISM CELLS ARE TRIANGULAR;
01800		IF CTRL THEN
01900		EUV ← 	(IF META THEN MKFE(U1,CELL,V2)
02000			         ELSE MKFE(V1,CELL,U2));
02100		U1←U2; V1←V2; NN←NN-1;
02200	END	"CELLS"	UNTIL U2=U0 ∨ NN=0;
02300	
02400		IF NCOUNT THEN 
02500		⊂ PED.(E0,F); NCNT.(NCOUNT,F0) ⊃;
02600		RETURN(F);
02700	END	"SWEEP";
02800	
02900	INTERNAL ISUBR PRISM (ITG F); RETURN(SWEEP(F,0,0));
03000	INTERNAL ISUBR CWPRISMIOD (ITG F); RETURN(SWEEP(F,1,1));
03100	INTERNAL ISUBR CCWPRISMIOD (ITG F); RETURN(SWEEP(F,0,1));
     

00100	α COMPLETE A SOLID OF ROTATION FROM A NON-ZERO NCOUNT SWEEPING FACE;
00200	INTERNAL PROCEDURE ROTCOM (ITG F);
00300	BEGIN	"ROTCOM"
00400		INTEGER NCOUNT;
00500	α BLESS THE ARGUMENTS;
00600		IF ¬FTYPE(F) THEN RETURN;
00700		NCOUNT ← NCNT(F); IF NCOUNT≥0 THEN RETURN;
00800		NCOUNT ← ABS(NCOUNT); NCNT.(NCOUNT,F);
00900	BEGIN
01000		INTEGER ARRAY PAIRS[-1:NCOUNT,1:2];
01100		INTEGER I,MTOTAL,SKPCNT,NN;
01200		INTEGER E,V,E0;
01300		INTEGER NNCNT;NNCNT←NCOUNT;NCOUNT←0;
01400	
01500	α SETUP THE PERIMETER COUNTS;
01600		NN ← NNCNT;
01700		E←E0←PED(F);
01800		MTOTAL←0; DO ⊂ E←ECCW(E,F);INCREM(MTOTAL) ⊃ UNTIL E=E0;
01900		SKPCNT	←	(MTOTAL - 2*NNCNT)%2 - 1;
02000	
02100	α CDR NNCNT+1 VERTICES DOWN THE PERIMETER;
02200		E ← E0;
02300		FOR I←0 STEP 1 UNTIL NNCNT DO
02400		⊂ PAIRS[I,1]←VCW(E,F); E←ECCW(E,F) ⊃;
02500	
02600	α SKIP AROUND A POLE CAP;
02700		FOR I←1 STEP 1 UNTIL SKPCNT DO E←ECCW(E,F);
02800	α CDR NNCNT+1 VERTICES UP THE PERIMETER;
02900		FOR I←NNCNT STEP -1 UNTIL 0 DO
03000		⊂ PAIRS[I,2]←VCW(E,F); E←ECCW(E,F) ⊃;
03100	α CALL JOINVV FOREACH PAIR;
03200		FOR I←0 STEP 1 UNTIL NN DO 
03300		E←MKFE(PAIRS[I,2],F,PAIRS[I,1]);
03400	END;
03500		RETURN;
03600	END	"ROTCOM";
     

00100	INTERNAL ITG PROCEDURE GLUE (ITG F1,F2);
00200	BEGIN	"GLUE"
00300	
00400		ITG B,B1,B2,F,E,V,E0;
00500		ITG V1,V2,E1,E2,F3;
00600		ITG CCW,CW,OF1,OF2;
00700		REAL X,Y,Z;
00800		INTEGER I,J,N;
00900		BOOLEAN BBFLG;
01000	
01100	α GET TWO FACES OFF THE PDL;
01200		BBFLG	←	FALSE;
01300		IF (¬FTYPE(F1) ∨ ¬FTYPE(F2))
01400		 ∧ BTYPE(F1) ∧ BTYPE(F2) THEN
01500	BEGIN
01600		B1	←	F1;
01700		B2	←	F2;
01800		BBFLG	←	TRUE;
01900	END ELSE ⊂ B1 ← BODY(F1); B2 ← BODY(F2);⊃;
02000	
02100	α BODY FUSION WHEN NECESSARY, B2 BECOMES B1;
02200		IF B1≠B2 THEN
02300		BEGIN
02400			ITG Q;
02500			F←NFACE(B1);
02600			Q←PFACE(B2);PFACE.(Q,F);Q←PFACE(B);NFACE.(F,Q);
02700			Q←NFACE(B2);PFACE.(Q,B1);Q←NFACE(B2);NFACE.(B1,Q);
02800	
02900			E←NED(B1);
03000			Q←PED(B2);PED.(Q,E);Q←PED(B);NED.(E,Q);
03100			Q←NED(B2);PED.(Q,B1);Q←NED(B2);NED.(B1,Q);
03200	
03300			V←NVT(B1);
03400			Q←PVT(B2);PVT.(Q,V);Q←PVT(B);NVT.(V,Q);
03500			Q←NVT(B2);PVT.(Q,B1);Q←NVT(B2);NVT.(B1,Q);
03600	
03700			KLB(B2);
03800		END;
03900	
04000		IF BBFLG THEN RETURN(B1);
04100		B ← B1;
     

00100		N ← NCNT(F1);
00200	α	IF N≠NCNT(F2) THEN RETURN(F1);
00300	
00400	BEGIN	"FGLUE"
00500		SAFE ITG ARRAY EARRY1,EARRY2,VARRY1,VARRY2[1:N];
00600	α PICK 'EM UP;
00700		E1←PED(F1);
00800		E2←PED(F2);
00900		FOR I←1 TO N DO
01000	BEGIN
01100		VARRY1[I] ← VCCW(E1,F1);
01200		EARRY1[I] ← E1;
01300		VARRY2[I] ← VCW(E2,F2);
01400		EARRY2[I] ← E2;
01500		E1 ← ECCW(E1,F1);
01600		E2 ←  ECW(E2,F2);
01700	END;
01800	
01900	α REPLACE V2 OCCURENCES WITH V1'S;
02000		FOR I←1 TO N DO
02100	BEGIN "VREPLACE"
02200		V1 ← VARRY1[I];
02300		V2 ← VARRY2[I];
02400		E←E0←PED(V2);
02500	DO BEGIN
02600		IF PVT(E)=V2 THEN PVT.(V1,E) ELSE NVT.(V1,E);
02700		E←ECCW(E,V1);
02800	END UNTIL E=E0;
02900	END "VREPLACE";
     

00100	α REPLACE F1 OCCURENCES WITH THE OTHER OF F2;
00200	α ...AND DO WING REPLACEMENTS;
00300		FOR I←1 TO N DO
00400	BEGIN
00500		E1 ← EARRY1[I];
00600		E2 ← EARRY2[I];
00700		OF1 ← OTHER(E1,F1);
00800		OF2 ← OTHER(E2,F2);
00900		CCW ← ECCW(E2,OF2);
01000		 CW ←  ECW(E2,OF2);
01100		OTHER.(OF2,E1,OF1);
01200		WING(CCW,E1);
01300		WING(CW,E1);
01400		IF PED(OF2)=E2 THEN PED.(E1,OF2);
01500	END;
01600	
01700		KLF(B,F1);
01800		KLF(B,F2);
01900		FOR I←1 TO N DO 
02000		⊂ KLE(B,EARRY2[I]);KLV(B,VARRY2[I]) ⊃;
02100	END	"FGLUE";
02200		RETURN(B);
02300	END	"GLUE";
02400	
     

00100	INTERNAL SUBR FVDUAL (ITG B);
00200	BEGIN	"FVDUAL"
00300		ITG Q1,Q2,F,E,V,E0,I;
00400		REAL X,Y,Z;
00500	
00600		IF ¬BTYPE(B) THEN RETURN;
00700	
00800	
00900	α COMPUTE CENTER LOCUS OF ALL THE FACES;
01000		F←PFACE(B);
01100		WHILE FTYPE(F) DO
01200	BEGIN
01300		X←Y←Z←0;I←0;
01400		E0←E←PED(F);
01500		DO BEGIN
01600			V ← VCCW(E,F);	E ← ECCW(E,F);
01700			X ← X + XWC(V);	Y ← Y + YWC(V);	Z ← Z + ZWC(V);
01800			I ← I + 1;
01900		END UNTIL E0=E;
02000		X←X/I;Y←Y/I;Z←Z/I;
02100		DACR(X,F-3);DACR(Y,F-2);DACR(Z,F-1);
02200		DAC(LAC(F+1),F+3); DIP(8,F);
02300		F ← PFACE(F);
02400	END;
02500	
02600		V←PVT(B);
02700		WHILE VTYPE(V) DO ⊂ DAC(LAC(V+3),V+1);DIP(2,V);V ← PVT(V);⊃;
02800		E←PED(B);
02900		WHILE ETYPE(E) DO
03000	BEGIN
03100		Q1 ← LAC(E+1);	Q2 ← LAC(E+3);
03200		DAC(Q1,E+3);	DAC(Q2,E+1);
03300		START_CODE MOVE 1,E;MOVSS 5(1);END;
03400		E ← PED(E);
03500	END;
03600		Q1 ← LAC(B+1);	Q2 ← LAC(B+3);
03700		DAC(Q1,B+3);	DAC(Q2,B+1);
03800	END "FVDUAL";
03900	END;
04000	KLEIN.SAI - EOF.